home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacGambit 2.0 / sources2 / Runtime (.scm & .s) / _ports.scm < prev    next >
Encoding:
Text File  |  1992-11-25  |  40.3 KB  |  962 lines  |  [TEXT/gamI]
  1. (##include "header.scm")
  2.  
  3. ;------------------------------------------------------------------------------
  4.  
  5. ; I/O stuff
  6.  
  7. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  8.  
  9. (define (##input-port? x)
  10.   (and (##subtyped? x)
  11.        (##fixnum.= (##subtype x) (subtype-port))
  12.        (##fixnum.< (##fixnum.modulo (port-kind x) 4) 2)))
  13.  
  14. (define (##output-port? x)
  15.   (and (##subtyped? x)
  16.        (##fixnum.= (##subtype x) (subtype-port))
  17.        (##fixnum.< 0 (##fixnum.modulo (port-kind x) 4))))
  18.  
  19. (define (##closed-port? x)
  20.   (and (##subtyped? x)
  21.        (##fixnum.= (##subtype x) (subtype-port))
  22.        (##fixnum.< 3 (port-kind x))))
  23.  
  24. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  25.  
  26. ; File I/O
  27.  
  28. (define (##make-port descr name kind read-proc write-proc ready-proc close-proc rbuf wbuf)
  29.   (let ((port (port-make)))
  30.     (port-kind-set!  port kind)
  31.     (port-name-set!  port name)
  32.     (port-read-set!  port (lambda (port)
  33.                             (let ((rbuf (port-rbuf port)))
  34.                               (let ((len (read-proc (port-misc port)
  35.                                                     rbuf
  36.                                                     0
  37.                                                     (##string-length rbuf))))
  38.                                 (if len
  39.                                   (begin
  40.                                     (port-pos-set! port 0)
  41.                                     (port-len-set! port len)
  42.                                     (##fixnum.= len 0))
  43.                                   (begin
  44.                                     (##signal '##SIGNAL.IO-ERROR "Read error on" port)
  45.                                     (port-pos-set! port 0)
  46.                                     (port-len-set! port 0)
  47.                                     #t))))))
  48.     (port-write-set! port (lambda (s i j port)
  49.                             (let loop ((i i))
  50.                               (let ((len (write-proc (port-misc port) s i j)))
  51.                                 (if len
  52.                                   (if (##fixnum.< 0 len)
  53.                                     (let ((i (##fixnum.+ len i)))
  54.                                       (if (##fixnum.< i j)
  55.                                         (loop i)))
  56.                                     (loop i))
  57.                                   (##signal '##SIGNAL.IO-ERROR "Write error on" port))))))
  58.     (port-ready-set! port (lambda (port) (ready-proc (port-misc port))))
  59.     (port-close-set! port (lambda (port)
  60.                             (if (##not (close-proc (port-misc port)))
  61.                               (##signal '##SIGNAL.IO-ERROR "Close error on" port))
  62.                             #t))
  63.     (port-pos-set!   port 0)
  64.     (port-len-set!   port 0)
  65.     (port-rbuf-set!  port rbuf)
  66.     (port-wbuf-set!  port wbuf)
  67.     (port-misc-set!  port descr)
  68.     port))
  69.  
  70. (define (##open-input-file s)
  71.   (let ((descr (##os-file-open-input s)))
  72.     (if descr
  73.       (##make-port descr s 0
  74.         ##os-file-read
  75.         #f
  76.         ##os-file-read-ready
  77.         ##os-file-close
  78.         (##make-string 64 #\space)
  79.         #f)
  80.       #f)))
  81.  
  82. (define (##open-output-file s)
  83.   (let ((descr (##os-file-open-output s)))
  84.     (if descr
  85.       (##make-port descr s 2
  86.         #f
  87.         ##os-file-write
  88.         #f
  89.         ##os-file-close
  90.         #f
  91.         (##make-string 1 #\space))
  92.       #f)))
  93.  
  94. (define (##open-input-output-file s)
  95.   (let ((descr (##os-file-open-input-output s)))
  96.     (if descr
  97.       (##make-port descr s 1
  98.         ##os-file-read
  99.         ##os-file-write
  100.         ##os-file-read-ready
  101.         ##os-file-close
  102.         (##make-string 64 #\space)
  103.         (##make-string 1 #\space))
  104.       #f)))
  105.  
  106. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  107.  
  108. ; String I/O
  109.  
  110. (define (##open-input-string str)
  111.   (let ((port (port-make)))
  112.     (port-kind-set!  port 0)
  113.     (port-name-set!  port 'STRING)
  114.     (port-read-set!  port (lambda (port) #t))
  115.     (port-write-set! port #f)
  116.     (port-ready-set! port (lambda (port) #t))
  117.     (port-close-set! port (lambda (port) #t))
  118.     (port-pos-set!   port 0)
  119.     (port-len-set!   port (##string-length str))
  120.     (port-rbuf-set!  port str)
  121.     (port-wbuf-set!  port #f)
  122.     port))
  123.  
  124. (define (##open-output-string)
  125.   (let ((port (port-make)))
  126.     (port-kind-set!  port 2)
  127.     (port-name-set!  port 'STRING)
  128.     (port-read-set!  port #f)
  129.     (port-write-set! port ##output-string-write)
  130.     (port-ready-set! port #f)
  131.     (port-close-set! port (lambda (port) #t))
  132.     (port-pos-set!   port 0)
  133.     (port-rbuf-set!  port #f)
  134.     (port-wbuf-set!  port (##make-string 1 #\space))
  135.     (port-misc-set!  port (##make-string 36 #\space)) ; 4 + 8*n
  136.     port))
  137.  
  138. (define (##output-string-write s i j port)
  139.   (let* ((str (port-misc port))
  140.          (pos (port-pos port))
  141.          (len (##string-length str))
  142.          (l (##fixnum.- j i))
  143.          (new-pos (##fixnum.+ pos l))
  144.          (overflow (##fixnum.- new-pos len)))
  145.     (if (##fixnum.< 0 overflow)
  146.       (let ((new-str (##make-string (##fixnum.+
  147.                                       (##fixnum.*
  148.                                         (##fixnum.quotient
  149.                                           (##fixnum.+ overflow 71)
  150.                                           8)
  151.                                         8)
  152.                                       len)
  153.                                     #\space)))
  154.         (let loop1 ((i (##fixnum.- pos 1)))
  155.           (if (##not (##fixnum.< i 0))
  156.             (begin
  157.               (##string-set! new-str i (##string-ref str i))
  158.               (loop1 (##fixnum.- i 1)))))
  159.         (port-misc-set! port new-str)))
  160.     (port-pos-set! port new-pos)
  161.     (let ((str (port-misc port)))
  162.       (let loop2 ((k (##fixnum.- l 1)))
  163.         (if (##not (##fixnum.< k 0))
  164.           (begin
  165.             (##string-set! str
  166.                            (##fixnum.+ pos k)
  167.                            (##string-ref s (##fixnum.+ i k)))
  168.             (loop2 (##fixnum.- k 1))))))
  169.     #f))
  170.  
  171. (define (##get-output-string port)
  172.   (let ((str (##substring (port-misc port) 0 (port-pos port))))
  173.     (port-pos-set! port 0)
  174.     str))
  175.  
  176. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  177.  
  178. (define (##close-port port)
  179.   (if (and (##not (##fixnum.< 3 (port-kind port)))
  180.            ((port-close port) port))
  181.     (port-kind-set! port (##fixnum.+ (##fixnum.modulo (port-kind port) 4) 4)))
  182.   #f)
  183.  
  184. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  185.  
  186. (define (##read-char port)
  187.   (let ((c (##peek-char port)))
  188.     (port-pos-set! port (##fixnum.+ (port-pos port) 1))
  189.     c))
  190.  
  191. (define (##peek-char port)
  192.   (let ((pos  (port-pos port))
  193.         (len  (port-len port))
  194.         (rbuf (port-rbuf port)))
  195.     (if (##fixnum.< pos len)
  196.       (##string-ref rbuf pos)
  197.       (if ((port-read port) port)
  198.         ##eof-object
  199.         (##peek-char port)))))
  200.  
  201. (define (##eof-object? x)
  202.   (##eq? x ##eof-object))
  203.  
  204. (define (##char-ready? port)
  205.   (let ((pos (port-pos port))
  206.         (len (port-len port)))
  207.     (if (##fixnum.< pos len)
  208.       #t
  209.       ((port-ready port) port))))
  210.  
  211. (define (##write-char c port)
  212.   (let ((wbuf (port-wbuf port)))
  213.     (##string-set! wbuf 0 c)
  214.     ((port-write port) wbuf 0 1 port)
  215.     #f))
  216.  
  217. (define (##write-string s port)
  218.   ((port-write port) s 0 (##string-length s) port)
  219.   #f)
  220.  
  221. (define (##write-substring s i j port)
  222.   (if (##fixnum.< i j) ((port-write port) s i j port))
  223.   #f)
  224.  
  225. (define (##newline port)
  226.   (##write-char #\newline port))
  227.  
  228. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  229.  
  230. (define (##read port)
  231.  
  232.   (##define-macro (+ . args)                `(##fixnum.+ ,@args))
  233.   (##define-macro (= . args)                `(##fixnum.= ,@args))
  234.   (##define-macro (< . args)                `(##fixnum.< ,@args))
  235.   (##define-macro (assq . args)             `(##assq ,@args))
  236.   (##define-macro (cdr . args)              `(##cdr ,@args))
  237.   (##define-macro (char->integer . args)    `(##char->integer ,@args))
  238.   (##define-macro (char-alphabetic? . args) `(##char-alphabetic? ,@args))
  239.   (##define-macro (char-downcase . args)    `(##char-downcase ,@args))
  240.   (##define-macro (char=? . args)           `(##char=? ,@args))
  241.   (##define-macro (cons . args)             `(##cons ,@args))
  242.   (##define-macro (set-cdr! . args)         `(##set-cdr! ,@args))
  243.   (##define-macro (eof-object? . args)      `(##eof-object? ,@args))
  244.   (##define-macro (list . args)             `(##list ,@args))
  245.   (##define-macro (make-string . args)      `(##make-string ,@args))
  246.   (##define-macro (make-vector . args)      `(##make-vector ,@args))
  247.   (##define-macro (not . args)              `(##not ,@args))
  248.   (##define-macro (string->number . args)   `(##string->number ,@args))
  249.   (##define-macro (string-set! . args)      `(##string-set! ,@args))
  250.   (##define-macro (vector-ref . args)       `(##vector-ref ,@args))
  251.   (##define-macro (vector-set! . args)      `(##vector-set! ,@args))
  252.  
  253.   (##define-macro (sf->locat sf)                #f)
  254.   (##define-macro (sf-peek-char sf)             `(##peek-char ,sf))
  255.   (##define-macro (sf-read-char sf)             `(##read-char ,sf))
  256.   (##define-macro (sf-read-error sf msg . args) `(##signal '##SIGNAL.READ-ERROR ,msg ,@args))
  257.   (##define-macro (make-source x locat)         x)
  258.   (##define-macro (source-code-set! source x)   x)
  259.   (##define-macro (string->canonical-symbol s)  `(##string->symbol ,s))
  260.  
  261.   (define QUOTE-sym            'quote)
  262.   (define QUASIQUOTE-sym       'quasiquote)
  263.   (define UNQUOTE-sym          'unquote)
  264.   (define UNQUOTE-SPLICING-sym 'unquote-splicing)
  265.  
  266.   (define char-newline #\newline)
  267.   (define false-object #f)
  268.  
  269.   (define named-char-table ##named-char-table)
  270.   (define read-table       ##read-table)
  271.  
  272. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  273.  
  274. ; For compatibility, `read-source' is the same reader as the one used in the
  275. ; compiler.  It has been copied from the file "gambit/compiler/source.scm".
  276.  
  277. (define (read-source sf)
  278.  
  279.   (define (read-char*)
  280.     (let ((c (sf-read-char sf)))
  281.       (if (eof-object? c)
  282.         (sf-read-error sf "Premature end of file encountered")
  283.         c)))
  284.  
  285.   (define (read-non-whitespace-char)
  286.     (let ((c (read-char*)))
  287.       (cond ((< 0 (vector-ref read-table (char->integer c)))
  288.              (read-non-whitespace-char))
  289.             ((char=? c #\;)
  290.              (let loop ()
  291.                (if (not (char=? (read-char*) char-newline))
  292.                  (loop)
  293.                  (read-non-whitespace-char))))
  294.             (else
  295.              c))))
  296.  
  297.   (define (delimiter? c)
  298.     (or (eof-object? c)
  299.         (not (= (vector-ref read-table (char->integer c)) 0))))
  300.  
  301.   (define (read-list first)
  302.     (let ((result (cons first '())))
  303.       (let loop ((end result))
  304.         (let ((c (read-non-whitespace-char)))
  305.           (cond ((char=? c #\)))
  306.                 ((and (char=? c #\.) (delimiter? (sf-peek-char sf)))
  307.                  (let ((x (read-source sf)))
  308.                    (if (char=? (read-non-whitespace-char) #\))
  309.                      (set-cdr! end x)
  310.                      (sf-read-error sf "')' expected"))))
  311.                 (else
  312.                  (let ((tail (cons (rd* c) '())))
  313.                    (set-cdr! end tail)
  314.                    (loop tail))))))
  315.       result))
  316.  
  317.   (define (read-vector)
  318.     (define (loop i)
  319.       (let ((c (read-non-whitespace-char)))
  320.         (if (char=? c #\))
  321.           (make-vector i '())
  322.           (let* ((x (rd* c))
  323.                  (v (loop (+ i 1))))
  324.             (vector-set! v i x)
  325.             v))))
  326.     (loop 0))
  327.  
  328.   (define (read-string)
  329.     (define (loop i)
  330.       (let ((c (read-char*)))
  331.         (cond ((char=? c #\")
  332.                (make-string i #\space))
  333.               ((char=? c #\\)
  334.                (let* ((c (read-char*))
  335.                       (s (loop (+ i 1))))
  336.                  (string-set! s i c)
  337.                  s))
  338.               (else
  339.                (let ((s (loop (+ i 1))))
  340.                  (string-set! s i c)
  341.                  s)))))
  342.     (loop 0))
  343.  
  344.   (define (read-symbol/number-string i)
  345.     (if (delimiter? (sf-peek-char sf))
  346.       (make-string i #\space)
  347.       (let* ((c (sf-read-char sf))
  348.              (s (read-symbol/number-string (+ i 1))))
  349.         (string-set! s i (char-downcase c))
  350.         s)))
  351.  
  352.   (define (read-symbol/number c)
  353.     (let ((s (read-symbol/number-string 1)))
  354.       (string-set! s 0 (char-downcase c))
  355.       (or (string->number s 10)
  356.           (string->canonical-symbol s))))
  357.  
  358.   (define (read-prefixed-number c)
  359.     (let ((s (read-symbol/number-string 2)))
  360.       (string-set! s 0 #\#)
  361.       (string-set! s 1 c)
  362.       (string->number s 10)))
  363.  
  364.   (define (read-special-symbol)
  365.     (let ((s (read-symbol/number-string 2)))
  366.       (string-set! s 0 #\#)
  367.       (string-set! s 1 #\#)
  368.       (string->canonical-symbol s)))
  369.  
  370.   (define (rd c)
  371.     (cond ((eof-object? c)
  372.            c)
  373.           ((< 0 (vector-ref read-table (char->integer c)))
  374.            (rd (sf-read-char sf)))
  375.           ((char=? c #\;)
  376.            (let loop ()
  377.              (let ((c (sf-read-char sf)))
  378.                (cond ((eof-object? c)
  379.                       c)
  380.                      ((char=? c char-newline)
  381.                       (rd (sf-read-char sf)))
  382.                      (else
  383.                       (loop))))))
  384.           (else
  385.            (rd* c))))
  386.  
  387.   (define (rd* c)
  388.     (let ((source (make-source #f (sf->locat sf))))
  389.       (source-code-set!
  390.         source
  391.         (cond ((char=? c #\()
  392.                (let ((x (read-non-whitespace-char)))
  393.                  (if (char=? x #\))
  394.                    '()
  395.                    (read-list (rd* x)))))
  396.               ((char=? c #\#)
  397.                (let ((c (char-downcase (sf-read-char sf))))
  398.                  (cond ((char=? c #\() (read-vector))
  399.                        ((char=? c #\f) false-object)
  400.                        ((char=? c #\t) #t)
  401.                        ((char=? c #\\)
  402.                         (let ((c (read-char*)))
  403.                           (if (or (not (char-alphabetic? c))
  404.                                   (delimiter? (sf-peek-char sf)))
  405.                             c
  406.                             (let ((name (read-symbol/number c)))
  407.                               (let ((x (assq name named-char-table)))
  408.                                 (if x
  409.                                   (cdr x)
  410.                                   (sf-read-error sf "Unknown character name:" name)))))))
  411.  
  412.                        ((char=? c #\#)
  413.                         (read-special-symbol))
  414.                        (else
  415.                         (let ((num (read-prefixed-number c)))
  416.                           (or num
  417.                               (sf-read-error sf "Unknown '#' read macro:" c)))))))
  418.               ((char=? c #\")
  419.                (read-string))
  420.               ((char=? c #\')
  421.                (list (make-source QUOTE-sym (sf->locat sf))
  422.                      (read-source sf)))
  423.               ((char=? c #\`)
  424.                (list (make-source QUASIQUOTE-sym (sf->locat sf))
  425.                      (read-source sf)))
  426.               ((char=? c #\,)
  427.                (if (char=? (sf-peek-char sf) #\@)
  428.                  (let ((x (make-source UNQUOTE-SPLICING-sym (sf->locat sf))))
  429.                    (sf-read-char sf)
  430.                    (list x (read-source sf)))
  431.                  (list (make-source UNQUOTE-sym (sf->locat sf))
  432.                        (read-source sf))))
  433.               ((char=? c #\))
  434.                (sf-read-error sf "Misplaced ')'"))
  435.               (else
  436.                (if (char=? c #\.)
  437.                  (if (delimiter? (sf-peek-char sf))
  438.                    (sf-read-error sf "Misplaced '.'")))
  439.                (read-symbol/number c))))))
  440.  
  441.   (rd (sf-read-char sf)))
  442.  
  443. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  444.  
  445.   (read-source port))
  446.  
  447. (define ##named-char-table #f)
  448. (set! ##named-char-table
  449.   (##list (##cons 'nul     (##integer->char 0))
  450.           (##cons 'tab     (##integer->char 9))
  451.           (##cons 'newline (##integer->char 10))
  452.           (##cons 'space   (##integer->char 32))))
  453.  
  454. (define ##read-table #f)
  455. (set! ##read-table
  456.   (let ((rt (##make-vector 256 0)))
  457.  
  458.     ; setup whitespace chars
  459.  
  460.     (let loop ((i 32))
  461.       (if (##not (##fixnum.< i 0))
  462.         (begin (##vector-set! rt i 1) (loop (##fixnum.- i 1)))))
  463.  
  464.     ; setup other delimiters
  465.  
  466.     (##vector-set! rt (##char->integer #\;) -1)
  467.     (##vector-set! rt (##char->integer #\() -1)
  468.     (##vector-set! rt (##char->integer #\)) -1)
  469.     (##vector-set! rt (##char->integer #\") -1)
  470.     (##vector-set! rt (##char->integer #\') -1)
  471.     (##vector-set! rt (##char->integer #\`) -1)
  472.  
  473.     rt))
  474.  
  475. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  476.  
  477. (define (##wr-unlimited obj port display? touch?)
  478.   (##fixnum.- (max-fixnum)
  479.               (##wr obj port display? touch? (max-fixnum))))
  480.  
  481. (define (##wr-limited obj port display? touch? limit)
  482.   (##fixnum.- limit
  483.               (##wr obj port display? touch? limit)))
  484.  
  485. (define (##wr obj port display? touch? limit)
  486.   (if (##fixnum.< 0 limit)
  487.     ((##vector-ref ##wr-type-table (##type obj))
  488.      obj
  489.      port
  490.      display?
  491.      touch?
  492.      limit)
  493.     0))
  494.  
  495. (define (##wr-str s port limit)
  496.   (##wr-substr s 0 (##string-length s) port limit))
  497.  
  498. (define (##wr-substr s i j port limit)
  499.   (let ((len (##fixnum.- j i)))
  500.     (if (##fixnum.< limit len)
  501.       (begin
  502.         (##write-substring s i (##fixnum.+ i limit) port)
  503.         0)
  504.       (begin
  505.         (##write-substring s i j port)
  506.         (##fixnum.- limit len)))))
  507.  
  508. (define (##wr-ch c port limit)
  509.   (if (##fixnum.< 0 limit)
  510.     (begin
  511.       (##write-char c port)
  512.       (##fixnum.- limit 1))
  513.     0))
  514.  
  515. (define (##wr-adr type obj port limit)
  516.   (##wr-str "]" port
  517.             (##wr-str (##number->string (##type-cast obj (type-fixnum)) 16) port
  518.                       (##wr-str " #x" port
  519.                                 (##wr-str type port
  520.                                           (##wr-str "#[" port limit))))))
  521.  
  522. (define (##wr-tag-in type tag name port limit)
  523.   (##wr-str "]" port
  524.             (##wr name port #f #f
  525.                   (##wr-str " in " port
  526.                             (##wr-str tag port
  527.                                       (##wr-str " " port
  528.                                                 (##wr-str type port
  529.                                                           (##wr-str "#[" port limit))))))))
  530.  
  531. (define (##wr-named type name port limit)
  532.   (##wr-str "]" port
  533.             (##wr name port #f #f
  534.                   (##wr-str " " port
  535.                             (##wr-str type port
  536.                                       (##wr-str "#[" port limit))))))
  537.  
  538. (define ##wr-type-table
  539.   (##make-vector (type-range)
  540.     (lambda (obj port display? touch? limit)
  541.       (##wr-adr (##string-append "type-"
  542.                                  (##number->string (##type obj) 10))
  543.                 obj
  544.                 port
  545.                 limit))))
  546.  
  547. (define ##wr-subtype-table
  548.   (##make-vector (subtype-range)
  549.     (lambda (obj port display? touch? limit)
  550.       (##wr-adr (##string-append "subtype-"
  551.                                  (##number->string (##subtype obj) 10))
  552.                 obj
  553.                 port
  554.                 limit))))
  555.  
  556. ; Setup type dispatch table
  557.  
  558. (##vector-set! ##wr-type-table (type-fixnum)
  559.   (lambda (obj port display? touch? limit)
  560.     (##wr-str (##number->string obj 10) port limit)))
  561.  
  562. (##vector-set! ##wr-type-table (type-special)
  563.   (lambda (obj port display? touch? limit)
  564.  
  565.     (define (assq-cdr x l)
  566.       (let loop ((y l))
  567.         (if (##pair? y)
  568.           (let ((couple (##car y)))
  569.             (if (##eq? x (##cdr couple)) couple (loop (##cdr y))))
  570.             #f)))
  571.  
  572.     (if (##char? obj)
  573.  
  574.       (if display?
  575.         (##wr-ch obj port limit)
  576.         (let ((x (assq-cdr obj ##named-char-table)))
  577.           (if x
  578.            (##wr-str (symbol-string (##car x)) port
  579.                      (##wr-str "#\\" port limit))
  580.            (##wr-ch obj port
  581.                     (##wr-str "#\\" port limit)))))
  582.  
  583.       (cond ((##eq? obj #t)
  584.              (##wr-str "#t" port limit))
  585.             ((##eq? obj #f)
  586.              (##wr-str "#f" port limit))
  587.             ((##eq? obj '())
  588.              (##wr-str "()" port limit))
  589.             ((##eq? obj ##undef-object)
  590.              (##wr-str "#[undefined]" port limit))
  591.             ((##eq? obj ##unass-object)
  592.              (##wr-str "#[unassigned]" port limit))
  593.             ((##eq? obj ##unbound-object)
  594.              (##wr-str "#[unbound]" port limit))
  595.             ((##eq? obj ##eof-object)
  596.              (##wr-str "#[eof]" port limit))
  597.             (else
  598.              (##wr-adr "special" obj port limit))))))
  599.  
  600. (##vector-set! ##wr-type-table (type-pair)
  601.   (lambda (obj port display? touch? limit)
  602.  
  603.     (define (wr-tail l limit)
  604.       (if (##fixnum.< 0 limit)
  605.         (let ((l (if touch? (touch-vars (l) l) l)))
  606.           (cond ((##pair? l)
  607.                  (wr-tail (##cdr l)
  608.                           (##wr (##car l) port display? touch?
  609.                                 (##wr-str " " port limit))))
  610.                 ((##null? l)
  611.                  (##wr-str ")" port limit))
  612.                 (else
  613.                  (##wr-str ")" port
  614.                            (##wr l port display? touch?
  615.                                  (##wr-str " . " port limit))))))
  616.         0))
  617.  
  618.     (define (wr-list x y limit)
  619.       (wr-tail y
  620.                (##wr x port display? touch?
  621.                      (##wr-str "(" port limit))))
  622.  
  623.     (let ((x (##car obj))
  624.           (y (##cdr obj)))
  625.       (if (and (##pair? y) (##null? (##cdr y)))
  626.         (let ((z (##car y)))
  627.           (case x
  628.             ((QUOTE)
  629.              (##wr z port display? touch?
  630.                    (##wr-str "'" port limit)))
  631.             ((QUASIQUOTE)
  632.              (##wr z port display? touch?
  633.                    (##wr-str "`" port limit)))
  634.             ((UNQUOTE)
  635.              (##wr z port display? touch?
  636.                    (##wr-str "," port limit)))
  637.             ((UNQUOTE-SPLICING)
  638.              (##wr z port display? touch?
  639.                    (##wr-str ",@" port limit)))
  640.             (else
  641.              (wr-list x y limit))))
  642.         (wr-list x y limit)))))
  643.  
  644. (##vector-set! ##wr-type-table (type-weak-pair)
  645.   (lambda (obj port display? touch? limit)
  646.     (##wr-adr "weak-pair" obj port limit)))
  647.  
  648. (##vector-set! ##wr-type-table (type-subtyped)
  649.   (lambda (obj port display? touch? limit)
  650.     ((##vector-ref ##wr-subtype-table (##subtype obj))
  651.      obj
  652.      port
  653.      display?
  654.      touch?
  655.      limit)))
  656.  
  657. (##vector-set! ##wr-type-table (type-procedure)
  658.   (lambda (obj port display? touch? limit)
  659.     (let ((name (##object->global-var-name obj)))
  660.       (if name
  661.         (##wr-named "procedure" name port limit)
  662.         (cond ((##proc-closure? obj)
  663.                (##wr-adr "procedure" obj port limit))
  664.               ((##proc-subproc? obj)
  665.                (let ((parent (##object->global-var-name (##proc-subproc-parent obj))))
  666.                  (if parent
  667.                    (##wr-tag-in "subprocedure" (##number->string (##proc-subproc-tag obj) 10) parent port limit)
  668.                    (##wr-adr "procedure" obj port limit))))
  669.               (else
  670.                (##wr-adr "procedure" obj port limit)))))))
  671.  
  672. (##vector-set! ##wr-type-table (type-placeholder)
  673.   (lambda (obj port display? touch? limit)
  674.     (if touch?
  675.       (touch-vars (obj)
  676.         (##wr obj port display? touch? limit))
  677.       (##wr-adr "placeholder" obj port limit))))
  678.  
  679. ; Setup subtype dispatch table
  680.  
  681. (##vector-set! ##wr-subtype-table (subtype-vector)
  682.   (lambda (obj port display? touch? limit)
  683.     (##wr (##vector->list obj) port display? touch?
  684.           (##wr-str "#" port limit))))
  685.  
  686. (##vector-set! ##wr-subtype-table (subtype-symbol)
  687.   (lambda (obj port display? touch? limit)
  688.     (##wr-str (symbol-string obj) port limit)))
  689.  
  690. (##vector-set! ##wr-subtype-table (subtype-port)
  691.   (lambda (obj port display? touch? limit)
  692.     (##wr-named (if (##input-port? obj)
  693.                   (if (##output-port? obj) "input-output-port" "input-port")
  694.                   "output-port")
  695.                 (port-name obj)
  696.                 port
  697.                 limit)))
  698.  
  699. (##vector-set! ##wr-subtype-table (subtype-ratnum)
  700.   (lambda (obj port display? touch? limit)
  701.     (##wr-str (##number->string obj 10) port limit)))
  702.     
  703. (##vector-set! ##wr-subtype-table (subtype-cpxnum)
  704.   (lambda (obj port display? touch? limit)
  705.     (##wr-str (##number->string obj 10) port limit)))
  706.  
  707. (##vector-set! ##wr-subtype-table (subtype-frame)
  708.   (lambda (obj port display? touch? limit)
  709.     (##wr-adr "frame" obj port limit)))
  710.  
  711. (##vector-set! ##wr-subtype-table (subtype-task)
  712.   (lambda (obj port display? touch? limit)
  713.     (##wr-adr "task" obj port limit)))
  714.  
  715. (##vector-set! ##wr-subtype-table (subtype-queue)
  716.   (lambda (obj port display? touch? limit)
  717.     (##wr-adr "queue" obj port limit)))
  718.  
  719. (##vector-set! ##wr-subtype-table (subtype-semaphore)
  720.   (lambda (obj port display? touch? limit)
  721.     (##wr-adr "semaphore" obj port limit)))
  722.  
  723. (##vector-set! ##wr-subtype-table (subtype-string)
  724.   (lambda (obj port display? touch? limit)
  725.  
  726.     (define (wr-str-quoted s port limit)
  727.       (let loop ((i 0) (j 0) (limit limit))
  728.         (if (##fixnum.< j (##string-length s))
  729.           (let ((c (##struch? col width extra)
  730.     (let* ((rest (##cdr expr))
  731.            (rest (if touch? (touch-vars (rest) rest) rest))
  732.            (named? (and (##pair? rest) (##symbol? (##car rest)))))
  733.       (pp-general expr port touch? col width extra named? pp-expr-list #f pp-expr)))
  734.  
  735.   (define (pp-let* expr port touch? col width extra)
  736.     (pp-general expr port touch? col width extra #f pp-expr-list #f pp-expr))
  737.  
  738.   (define (pp-letrec expr port touch? col width extra)
  739.     (pp-general expr port touch? col width extra #f pp-expr-list #f pp-expr))
  740.  
  741.   (define (pp-begin expr port touch? col width extra)
  742.     (pp-general expr port touch? col width extra #f #f #f pp-expr))
  743.  
  744.   (define (pp-do expr port touch? col width extra)
  745.     (pp-general expr port touch? col width extra #f pp-expr-list pp-expr-list pp-expr))
  746.  
  747.   (define (pp-define expr port touch? col width extra)
  748.     (pp-general expr port touch? col width extra #f pp-expr-list #f pp-expr))
  749.  
  750.   (define (pp-style x)
  751.     (case x
  752.       ((quote) pp-quote)
  753.       ((quasiquote) pp-quasiquote)
  754.       ((unquote) pp-unquote)
  755.       ((unquote-splicing) pp-unquote-splicing)
  756.       ((lambda) pp-lambda)
  757.       ((if) pp-if)
  758.       ((set!) pp-set!)
  759.       ((cond) pp-cond)
  760.       ((case) pp-case)
  761.       ((and) pp-and)
  762.       ((or) pp-or)
  763.       ((let) pp-let)
  764.       ((let*) pp-let*)
  765.       ((letrec) pp-letrec)
  766.       ((begin) pp-begin)
  767.       ((do) pp-do)
  768.       ((define) pp-define)
  769.       (else #f)))
  770.  
  771.   (p obj port touch? col width 0 pp-expr))
  772.  
  773. (define (##pretty-print obj port width)
  774.   (##pretty obj port (if-touches #t #f) 0 width)
  775.   (##newline port))
  776.  
  777. (define (##object->string obj width touch?)
  778.   (let ((port (##open-output-string)))
  779.     (##wr-limited obj port #f touch? (##fixnum.+ width 1))
  780.     (let* ((str (##get-output-string port))
  781.            (len (##string-length str)))
  782.       (##close-port port)
  783.       (if (##fixnum.< width len)
  784.         (begin
  785.           (##string-set! str (##fixnum.- width 1) #\.)
  786.           (##string-set! str (##fixnum.- width 2) #\.)
  787.           (##string-set! str (##fixnum.- width 3) #\.)
  788.           (##string-shrink! str width)
  789.           str)
  790.         str))))
  791.  
  792. (define (##format port str . args)
  793.   (let ((len (##string-length str)))
  794.     (let loop ((i 0) (j 0) (args args))
  795.       (if (##not (##fixnum.< j len))
  796.         (##write-substring str i j port)
  797.         (let ((c (##string-ref str j)))
  798.           (if (##char=? c #\~)
  799.             (let ((c (##string-ref str (##fixnum.+ j 1))))
  800.               (##write-substring str i j port)
  801.               (if (##memq c '(#\A #\S #\V #\D #\B #\O #\X))
  802.                 (let ((arg (##car args))
  803.                       (rest (##cdr args)))
  804.                   (cond ((##char=? c #\A)
  805.                          (##display arg port #t))
  806.                         ((##char=? c #\S)
  807.                          (##write arg port #t))
  808.                         ((##char=? c #\V)
  809.                          (##wr-unlimited arg port #f #f))
  810.                         ((##char=? c #\D)
  811.                          (##write-string (##number->string arg 10) port))
  812.                         ((##char=? c #\B)
  813.                          (##write-string (##number->string arg 2) port))
  814.                         ((##char=? c #\O)
  815.                          (##write-string (##number->string arg 8) port))
  816.                         ((##char=? c #\X)
  817.                          (##write-string (##number->string arg 16) port)))
  818.                   (loop (##fixnum.+ j 2) (##fixnum.+ j 2) rest))
  819.                 (cond ((##char=? c #\%)
  820.                        (##newline port)
  821.                        (loop (##fixnum.+ j 2) (##fixnum.+ j 2) args))
  822.                       ((##char=? c #\~)
  823.                        (##write-string "~" port)
  824.                        (loop (##fixnum.+ j 2) (##fixnum.+ j 2) args))
  825.                       ((##char=? c #\newline)
  826.                        (let ((k (let skip ((j (##fixnum.+ j 2)))
  827.                                   (cond ((##not (##fixnum.< j len))
  828.                                          j)
  829.                                         ((##char-whitespace? c)
  830.                                          (skip (##fixnum.+ j 1)))
  831.                                         (else
  832.                                          j)))))
  833.                          (loop k k args)))
  834.                       (else
  835.                        (loop (##fixnum.+ j 2) (##fixnum.+ j 2) args)))))
  836.             (loop i (##fixnum.+ j 1) args)))))))
  837.  
  838. ;------------------------------------------------------------------------------
  839.  
  840. (define (##stdin-read descr rbuf i j)
  841.   (let ((len (##os-file-read descr rbuf i j)))
  842.     (if len
  843.       (let ((p ##transcript-port))
  844.         (if (and (##fixnum.< 0 len)
  845.                  (##output-port? p)
  846.                  (##not (##closed-port? p)))
  847.           (##write-substring rbuf i j p))))
  848.     len))
  849.  
  850. (define ##stdin
  851.   (let ((port
  852.           (##make-port 0 'STDIN 0
  853.             ##stdin-read
  854.             #f
  855.             ##os-file-read-ready
  856.             #f
  857.             (##make-string 1 #\space)
  858.             #f)))
  859.     (port-close-set! port (lambda (port) (##os-file-close (port-misc port)) #f))
  860.     port))
  861.  
  862. (define (##stdout-write descr s i j)
  863.   (let ((len (##os-file-write descr s i j)))
  864.     (if len
  865.       (let ((p ##transcript-port))
  866.         (if (and (##fixnum.< 0 len)
  867.                  (##output-port? p)
  868.                  (##not (##closed-port? p)))
  869.           (##write-substring s i j p))))
  870.     len))
  871.  
  872. (define ##stdout
  873.   (let ((port
  874.           (##make-port 1 'STDOUT 2
  875.             #f
  876.             ##stdout-write
  877.             #f
  878.             #f
  879.             #f
  880.             (##make-string 1 #\space))))
  881.     (port-close-set! port (lambda (port) (##os-file-close (port-misc port)) #f))
  882.     port))
  883.  
  884. (define ##stderr
  885.   (let ((port
  886.           (##make-port 2 'STDERR 2
  887.             #f
  888.             ##stdout-write
  889.             #f
  890.             #f
  891.             #f
  892.             (##make-string 1 #\space))))
  893.     (port-close-set! port (lambda (port) (##os-file-close (port-misc port)) #f))
  894.     port))
  895.  
  896. (define (##transcript-on port)
  897.   (set! ##transcript-port port)
  898.   #f)
  899.  
  900. (define (##transcript-off port)
  901.   (set! ##transcript-port #f)
  902.   #f)
  903.  
  904. (define ##transcript-port #f)
  905.  
  906. (define (##current-input-port)
  907.   (##dynamic-ref '##CURRENT-INPUT-PORT ##stdin))
  908.  
  909. (define (##current-output-port)
  910.   (##dynamic-ref '##CURRENT-OUTPUT-PORT ##stdout))
  911.  
  912. (define (##port-width port)
  913.   (##dynamic-ref '##PORT-WIDTH 79))
  914.  
  915. ;------------------------------------------------------------------------------
  916.  
  917. (define (##load s trace-port)
  918.  
  919.   (define (load-from-port port)
  920.     (let loop ()
  921.       (let ((expr (##read port)))
  922.         (if (##not (##eof-object? expr))
  923.           (let ((val (##eval-global expr)))
  924.             (if trace-port
  925.               (begin
  926.                 (##write val trace-port (if-touches #t #f))
  927.                 (##newline trace-port)))
  928.             (loop))
  929.           (##close-port port)))))
  930.  
  931.   (define (remove-extension str ext)
  932.     (let ((lstr (##string-length str))
  933.           (lext (##string-length ext)))
  934.       (cond ((##fixnum.< lstr lext)
  935.              str)
  936.             ((##string=? (##substring str (##fixnum.- lstr lext) lstr) ext)
  937.              (##substring str 0 (##fixnum.- lstr lext)))
  938.             (else
  939.              str))))
  940.  
  941.   (let* ((name (remove-extension s ".O"))
  942.          (name* (##string-append name ".O"))
  943.          (port (##open-input-file name*)))
  944.     (if port
  945.       (begin
  946.         (##close-port port)
  947.         (let ((msg (##load-object-file name)))
  948.           (if (##procedure? msg)
  949.             (begin (msg) name*)
  950.             (trap-load (load name*) msg))))
  951.       (let* ((name (remove-extension s ".scm"))
  952.              (name* (##string-append name ".scm"))
  953.              (port (##open-input-file name*)))
  954.         (if port
  955.           (begin (load-from-port port) name*)
  956.           (let ((port (##open-input-file s)))
  957.             (if port
  958.               (begin (load-from-port port) s)
  959.               (trap-open-file (load s)))))))))
  960.  
  961. ;------------------------------------------------------------------------------
  962.